Libraries, constants, and plotting set-up.
library(ggplot2)
library(dplyr)
library(purrr)
n <- 14
cols <- seq(1, n/2)
colors <- c(
"#d33682", # magenta
"#dc322f", # red
"#cb4b16", # orange
"#b58900", # yellow
"#859900", # green
"#2aa198", # cyan
"#268bd2", # blue
"#6c71c4", # violet
"#993399" # purple
)
theme_blank <- function() {
theme(axis.line = element_blank(),
axis.text.x = element_blank(),
axis.text.y = element_blank(),
axis.ticks = element_blank(),
axis.title.x = element_blank(),
axis.title.y = element_blank(),
legend.position = "none",
panel.background = element_blank(),
panel.border = element_blank(),
panel.grid.major = element_blank(),
panel.grid.minor = element_blank(),
plot.background = element_blank())
}
plt <- function(data) {
ggplot() +
geom_segment(aes(x = x, xend = xend, y = y, yend = yend, color = factor(color)),
data = data, size = 0.3) +
scale_color_manual(values = colors) +
coord_fixed() +
theme_blank()
}Basic building blocks.
blank <- function() {
data.frame(y = numeric(0),
yend = numeric(0),
x = numeric(0),
xend = numeric(0),
color = numeric(0))
}
sector <- function() {
data.frame(
y = c(0, n, seq(n, 1)),
yend = c(0, 0, rep(0, n)),
x = c(n, 0, rep(0, n)),
xend = c(0, 0, seq(1, n)),
color = c(0, 0, c(cols, rev(cols))))
}
square <- function() {
data.frame(
y = c(0, n, n, n, seq(n, 1), seq(n, 1)),
yend = c(0, 0, n, 0, rep(0, n), rep(n, n)),
x = c(n, 0, n, n, rep(0, n), rep(n, n)),
xend = c(0, 0, 0, n, seq(1, n), seq(1, n)),
color = c(0, 0, 0, 0, c(cols, rev(cols)), c(cols, rev(cols))))
}
diamond <- function() {
data.frame(
y = c(0, n, seq(n, 1), seq(n, 1), seq(-n, -1), seq(-n, -1)),
yend = c(0, -n, rep(rep(0, n), 4)),
x = c(n, 0, rep(rep(0, n), 4)),
xend = c(-n, 0, seq(1, n), seq(-1, -n), seq(1, n), seq(-1, -n)),
color = c(0, 0, rep(c(cols, rev(cols)), 4)))
}Transformation functions.
translate <- function(data, dx, dy) {
mutate(data,
x = x + dx, xend = xend + dx,
y = y + dy, yend = yend + dy)
}
rotate <- function(data, theta) {
rot.coords <- matrix(c(cos(theta), -sin(theta), sin(theta), cos(theta)), ncol = 2,
dimnames = list(NULL, c("x", "y")))
rot.ends <- matrix(c(cos(theta), -sin(theta), sin(theta), cos(theta)), ncol = 2,
dimnames = list(NULL, c("xend", "yend")))
bind_cols(as.data.frame(as.matrix(select(data, x, y)) %*% rot.coords),
as.data.frame(as.matrix(select(data, xend, yend)) %*% rot.ends),
select(data, color))
}
scale <- function(data, v) {
bind_cols(select(data, -color) * v, select(data, color))
}
map.trans <- function(data, x, y) {
bind_rows(map2(x, y, function(i, j) translate(data, i*n, j*n)))
}
sign_zp <- function(v) replace(sign(v), sign(v) == 0, 1)
sign_zn <- function(v) replace(sign(v), sign(v) == 0, -1)
increase_zp <- function(v, s) sign_zp(v) * (abs(v) + s)
increase_zn <- function(v, s) sign_zn(v) * (abs(v) + s)Building up more complex shapes out of building blocks.
row <- function(data, k) {
if (k == 0) return(blank())
bind_rows(map(seq(-k+1, k-1, by = 2), function(x) translate(data, x*n, 0)))
}
bottom.pyramid <- function(data, base) {
if (base == 0) return(blank())
bind_rows(map(seq(1, base), function(w) translate(row(data, w), 0, (w-1)*n)))
}
top.pyramid <- function(data, base) {
if (base == 0) return(blank())
bind_rows(map(seq(1, base), function(w) translate(row(data, w), 0, -(w-1)*n)))
}
meta.diamond <- function(maxw) {
bind_rows(bottom.pyramid(diamond(), maxw),
translate(top.pyramid(diamond(), maxw-1), 0, (maxw+maxw-2)*n)) %>%
translate(0, -(maxw-1)*n)
}
uni.meta.diamond <- function(k) {
meta.diamond(k) %>% scale(1/k)
}Fractals!
fractal_layer <- function(level, depth, growth, direction) {
tx <- c(0, 0, 2, -2)*(level-1)
ty <- c(2, -2, 0, 0)*(level-1)
dx <- unlist(map(0:(depth-level),
function(i) c(increase_zp(tx, i), increase_zn(tx, i))))
dy <- unlist(map(0:(depth-level),
function(i) c(increase_zp(ty, i), increase_zn(ty, i))))
base <- switch(direction,
max_in = level,
max_out = depth - level + 1)
layer <- switch(growth,
linear = map.trans(uni.meta.diamond(base), c(tx, dx), c(ty, dy)),
exponential = map.trans(uni.meta.diamond(2^(base-1)), c(tx, dx), c(ty, dy)))
return(layer)
}
fractal <- function(depth, growth = "linear", direction = "max_in") {
x1 <- c(1, 1, -1, -1)
y1 <- c(1, -1, 1, -1)
inner_size <- switch(growth,
linear = depth,
exponential = 2^(depth-1))
start <- switch(direction,
max_in = uni.meta.diamond(1),
max_out = uni.meta.diamond(inner_size))
l1 <- map.trans(start,
c(0, unlist(map(1:(depth-1), function(l) x1*l))),
c(0, unlist(map(1:(depth-1), function(l) y1*l))))
ls <- bind_rows(map(2:depth, function(level) fractal_layer(level, depth, growth, direction)))
bind_rows(l1, ls)
}
circle_fractal_layer <- function(level) {
tx <- c(0, 0, 2, -2)*(level-1)
ty <- c(2, -2, 0, 0)*(level-1)
odd <- 2*level-3
dx <- rep(c(-(odd):-1, 1:(odd)), each=2)
dy <- rep(c(1:(odd), (odd):1), each=2) * rep(c(1, -1), 2*(odd))
map.trans(uni.meta.diamond(level), c(tx, dx), c(ty, dy))
}
circle_fractal <- function(depth) {
bind_rows(uni.meta.diamond(1),
bind_rows(map(2:depth, function(level) circle_fractal_layer(level))))
}fractal(4, "linear", "max_in") %>% plt()fractal(4, "exponential", "max_in") %>% plt()fractal(4, "linear", "max_out") %>% plt()